{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Lambola.IDL.ParsecLexer
-- Copyright   :  (c) Stephen Tetley 2014
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Parsec Lexer.
-- 
--------------------------------------------------------------------------------

module Lambola.IDL.ParsecLexer
  ( 
    IDLParser
  , IDLLexer

  , whiteSpace
  , identifier
  , unresolvedIdentifier
  , keyword
  , operator

  , terminated
  , braces
  , parens
  , angles
  , squares
  
  , semi
  , colon
  , comma

  , charLiteral
  , stringLiteral
  , hexadecimal
  , decimal
  , octal
  , float  


  , lex_def
  , idl_lex

  ) where

import Lambola.IDL.Syntax

import Text.Parsec
import Text.Parsec.Language
import qualified Text.Parsec.Token as P

import Control.Applicative hiding ( (<|>), many )
import Control.Monad.Identity

type IDLParser a    = ParsecT String () Identity a
type IDLLexer       = P.GenTokenParser String () Identity


lexeme              :: IDLParser a -> IDLParser a
lexeme              = P.lexeme idl_lex

whiteSpace          :: IDLParser ()
whiteSpace          = P.whiteSpace idl_lex

identifier          :: IDLParser Identifier
identifier          = P.identifier idl_lex

unresolvedIdentifier          :: IDLParser Identifier
unresolvedIdentifier = identifier <|> return "%unresovled"

keyword             :: String -> IDLParser ()
keyword             = P.reserved idl_lex


terminated          :: IDLParser a -> IDLParser b -> IDLParser a
terminated p t      = p <* t

operator            :: String -> IDLParser ()
operator            = P.reservedOp idl_lex

braces              :: IDLParser a -> IDLParser a
braces              = P.braces idl_lex

parens              :: IDLParser a -> IDLParser a
parens              = P.parens idl_lex

angles              :: IDLParser a -> IDLParser a
angles              = P.brackets idl_lex

squares             :: IDLParser a -> IDLParser a
squares             = P.squares idl_lex

semi                :: IDLParser String
semi                = P.semi idl_lex

colon               :: IDLParser String
colon               = P.colon idl_lex

comma               :: IDLParser String
comma               = P.comma idl_lex


charLiteral         :: IDLParser Char
charLiteral         = P.charLiteral idl_lex

stringLiteral       :: IDLParser String
stringLiteral       = P.stringLiteral idl_lex



-- IDL has different prefix rules to Haskell for octal

hexadecimal         :: IDLParser Integer
hexadecimal         = P.hexadecimal idl_lex

decimal             :: IDLParser Integer
decimal             = P.decimal idl_lex


octal               :: IDLParser Integer
octal               = lexeme body1 
  where
    body1 = (\xs -> read $ '0':'o':xs) 
              <$> (char '0' *> many1 (oneOf "01234567"))

float               :: IDLParser Double
float               = P.float idl_lex





idl_lex             :: IDLLexer
idl_lex             = P.makeTokenParser lex_def


lex_def :: LanguageDef st
lex_def = emptyDef
    { P.commentStart      = "/*"
    , P.commentEnd        = "*/"
    , P.commentLine       = "//"
    , P.identStart        = letter <|> char '_'
    , P.identLetter       = alphaNum <|> char '_'
    , P.reservedOpNames   = idl_operators
    , P.reservedNames     = idl_keywords
    , P.caseSensitive     = True
    }


idl_keywords :: [String]
idl_keywords = 
    [ "any"
    , "attribute"
    , "boolean"
    , "case"
    , "char"
    , "const"
    , "context"
    , "default"
    , "double"
    , "enum"
    , "exception"
    , "FALSE"
    , "float"
    , "in"
    , "inout"
    , "interface"
    , "local"
    , "long"
    , "module"
    , "native"
    , "Object"
    , "octet"
    , "oneway"
    , "out"
    , "raises"
    , "readonly"
    , "sequence"
    , "short"
    , "string"
    , "struct"
    , "switch"
    , "TRUE"
    , "typedef"
    , "unsigned"
    , "union"
    , "void"
    ]

idl_operators :: [String]
idl_operators = 
    [ "::", "=", "|", "^", "&", ">>", "<<", "+", "-", "*", "/", "%", "~" ]
    